home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clx.lha / clx / debug / util.l < prev   
Text File  |  1988-09-12  |  5KB  |  165 lines
  1. ;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES; -*-
  2.  
  3. ;; CLX utilities
  4.  
  5. ;;;
  6. ;;;             TEXAS INSTRUMENTS INCORPORATED
  7. ;;;                  P.O. BOX 2909
  8. ;;;                   AUSTIN, TEXAS 78769
  9. ;;;
  10. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  11. ;;;
  12. ;;; Permission is granted to any individual or institution to use, copy, modify,
  13. ;;; and distribute this software, provided that this complete copyright and
  14. ;;; permission notice is maintained, intact, in all copies and supporting
  15. ;;; documentation.
  16. ;;;
  17. ;;; Texas Instruments Incorporated provides this software "as is" without
  18. ;;; express or implied warranty.
  19. ;;;
  20.  
  21. ;;; Created 04/09/87 14:30:41 by LaMott G. OREN
  22.  
  23. (in-package "XLIB" :use '("LISP"))
  24.  
  25. (export '(display-root
  26.       display-black
  27.       display-white
  28.       report-events
  29.       describe-window
  30.       describe-gc
  31.       degree
  32.       radian
  33.       display-refresh
  34.       root-tree
  35.       window-tree))
  36.  
  37. (defun display-root (display) (screen-root (display-default-screen display)))
  38. (defun display-black (display) (screen-black-pixel (display-default-screen display)))
  39. (defun display-white (display) (screen-white-pixel (display-default-screen display)))
  40.  
  41. (defun report-events (display)
  42.   (loop
  43.     (unless
  44.       (process-event display :handler #'(lambda (&rest args) (print args)) :discard-p t :timeout 0.001)
  45.       (return nil))))
  46.  
  47. (defun describe-window (window)
  48.   (macrolet ((da (attribute &key (transform 'progn) (format "~s"))
  49.            (let ((func (intern (concatenate 'string "WINDOW-" (string attribute)) 'xlib)))
  50.          `(format t "~%~22a ~?" ',attribute ,format (list (,transform (,func window))))))
  51.          (dg (attribute &key (transform 'progn) (format "~s"))
  52.            (let ((func (intern (concatenate 'string "DRAWABLE-" (string attribute)) 'xlib)))
  53.          `(format t "~%~22a ~?" ',attribute ,format (list (,transform (,func window)))))))
  54.     (with-state (window)
  55.       (when (window-p window)
  56.     (da visual :format "#x~x")
  57.     (da class)
  58.     (da gravity)
  59.     (da bit-gravity)
  60.     (da backing-store)
  61.     (da backing-planes :format "#x~x")
  62.     (da backing-pixel)
  63.     (da save-under)
  64.     (da colormap)
  65.     (da colormap-installed-p)
  66.     (da map-state)
  67.     (da all-event-masks :transform make-event-keys :format "~~{~<~%~1:;~s ~>~}~")
  68.     (da event-mask :transform make-event-keys :format "~~{~<~%~1:;~s ~>~}~")
  69.     (da do-not-propagate-mask :transform make-event-keys :format "~~{~<~%~1:;~s ~>~}~")
  70.     (da override-redirect)
  71.     )
  72.       (dg root)
  73.       (dg depth)
  74.       (dg x)
  75.       (dg y)
  76.       (dg width)
  77.       (dg height)
  78.       (dg border-width)
  79.  
  80.       )))
  81.       
  82. (defun describe-gc (gc)
  83.   (macrolet ((dgc (name &key (transform 'progn) (format "~s"))
  84.            (let ((func (intern (concatenate 'string "GCONTEXT-" (string name)) 'xlib)))
  85.          `(format t "~%~22a ~?" ',name ,format (list (,transform (,func gc)))))))
  86.     (dgc function)
  87.     (dgc plane-mask)
  88.     (dgc foreground)
  89.     (dgc background)
  90.     (dgc line-width)
  91.     (dgc line-style)
  92.     (dgc cap-style)
  93.     (dgc join-style)
  94.     (dgc fill-style)
  95.     (dgc fill-rule)
  96.     (dgc tile)
  97.     (dgc stipple)
  98.     (dgc ts-x)
  99.     (dgc ts-y)
  100.     (dgc font) ;; See below
  101.     (dgc subwindow-mode)
  102.     (dgc exposures)
  103.     (dgc clip-x)
  104.     (dgc clip-y)
  105. ;;    (dgc clip-ordering)
  106.     (dgc clip-mask)
  107.     (dgc dash-offset)
  108.     (dgc dashes)
  109.     (dgc arc-mode)
  110.     ))
  111.  
  112. (defun degree (degrees)
  113.   (* degrees (/ pi 180)))
  114.  
  115. (defun radian (radians)
  116.   (round (* radians (/ 180 pi))))
  117.  
  118. (defun display-refresh (host)
  119.   ;; Useful for when the system writes to the screen (sometimes scrolling!)
  120.   (let ((display (open-display host)))
  121.     (unwind-protect
  122.     (let ((screen (display-default-screen display)))
  123.       (let ((win (create-window :parent (screen-root screen) :x 0 :y 0 :override-redirect :on
  124.                     :width (screen-width screen) :height (screen-height screen)
  125.                     :background (screen-black-pixel screen))))
  126.         (map-window win)
  127.         (display-finish-output display)
  128.         (unmap-window win)
  129.         (destroy-window win)
  130.         (display-finish-output display)))
  131.       (close-display display))))
  132.  
  133. (defun root-tree (host)
  134.   (let ((display (open-display host)))
  135.     (unwind-protect
  136.     (window-tree (screen-root (display-default-screen display)))
  137.       (close-display display)))
  138.   (values))
  139.  
  140. (defun window-tree (window &optional (depth 0))
  141.   ;; Print the window tree and properties starting from WINDOW
  142.   ;; Returns a list of windows in the order that they are printed.
  143.   (declare (arglist window)
  144.        (type window window)
  145.        (values (list window)))
  146.   (let ((props (mapcar #'(lambda (prop)
  147.                (multiple-value-bind (data type format)
  148.                    (get-property window prop)
  149.                  (case type
  150.                    (:string (setq data (coerce data 'string))))
  151.                  (list prop format type data)))
  152.                (list-properties window)))
  153.     (result (list window)))
  154.     (with-state (window)
  155.       (format t "~%~v@t#x~x~20,20t X~3d Y~3d W~4d H~3d ~s" depth (window-id window)
  156.           (drawable-x window) (drawable-y window)
  157.           (drawable-width window) (drawable-height window)
  158.           (window-map-state window)))
  159.     (dolist (prop props)
  160.       (format t "~%~v@t~{~s ~}" (+ depth 2) prop))
  161.     (dolist (w (query-tree window))
  162.       (setq result (nconc result (window-tree w (+ depth 2)))))
  163.     result))
  164.  
  165.